HW_2
2023-11-12
Задание 1
df <- read_rds('life_expectancy_data.RDS')
str(df)## Classes 'data.table' and 'data.frame': 195 obs. of 23 variables:
## $ Country : chr "Afghanistan" "Albania" "Algeria" "Angola" ...
## $ Year : int 2019 2019 2019 2019 2019 2019 2019 2019 2019 2019 ...
## $ Gender : chr "Female" "Female" "Female" "Female" ...
## $ Life expectancy : num 66.4 80.2 78.1 64 78.1 ...
## $ Unemployment : num 14.06 11.32 18.63 7.84 8.26 ...
## $ Infant Mortality : num 42.9 7.7 18.6 44.5 5.1 ...
## $ GDP : num 1.88e+10 1.54e+10 1.72e+11 8.94e+10 1.69e+09 ...
## $ GNI : num 1.91e+10 1.52e+10 1.68e+11 8.19e+10 1.58e+09 ...
## $ Clean fuels and cooking technologies : num 36 80.7 99.3 49.6 100 ...
## $ Per Capita : num 494 5396 3990 2810 17377 ...
## $ Mortality caused by road traffic injury: num 15.9 11.7 20.9 26.1 0 ...
## $ Tuberculosis Incidence : num 189 16 61 351 0 29 26 2.2 6.9 6 ...
## $ DPT Immunization : num 66 99 91 57 95 ...
## $ HepB3 Immunization : num 66 99 91 53 99 ...
## $ Measles Immunization : num 64 95 80 51 93 ...
## $ Hospital beds : num 0.432 3.052 1.8 0.8 2.581 ...
## $ Basic sanitation services : num 49 99.2 86.1 51.4 85.5 ...
## $ Tuberculosis treatment : num 91 88 86 69 72.3 ...
## $ Urban population : num 25.8 61.2 73.2 66.2 24.5 ...
## $ Rural population : num 74.2 38.8 26.8 33.8 75.5 ...
## $ Non-communicable Mortality : num 36.2 6 12.8 19.4 17.6 ...
## $ Sucide Rate : num 3.6 2.7 1.8 2.3 0.8 ...
## $ continent : Factor w/ 5 levels "Africa","Americas",..: 3 4 1 1 2 2 4 2 5 4 ...
## - attr(*, ".internal.selfref")=<externalptr>
## - attr(*, "sorted")= chr "Country"#summary(df)Задание 2
Сделайте интерактивный plotly график любых двух нумерических колонок. Раскрасть по колонке континента, на котором расположена страна
plot_ly(
data = df[(df$`HepB3 Immunization` != 0) & (df$`Urban population` != 0),],
x = ~ `HepB3 Immunization` ,
y = ~ `Urban population`,
color = ~ continent,
colors = "Set2"
) |>
layout(
title = 'Соотношение городского населения и уровня иммунизации от гепатита B',
yaxis = list(title = 'Urban population',
zeroline = FALSE),
xaxis = list(title = 'HepB3 Immunization',
zeroline = FALSE))Задание 3
Проведите тест, на сравнение распределений колонки
Life expectancy между группами стран Африки и Америки. Вид
статистического теста определите самостоятельно. Визуализируйте
результат через библиотеку rstatix.
df |>
get_summary_stats(`Life expectancy`, type = "mean_sd")## # A tibble: 1 × 4
## variable n mean sd
## <fct> <dbl> <dbl> <dbl>
## 1 Life expectancy 195 75.5 7.68df_continent <- df |>
filter(continent %in% c('Africa', 'Americas'))
#QQ-plot
ggqqplot(df_continent,
x = "Life expectancy", facet.by = "continent")
#Применение теста Шапиро-Уилка для оценки нормальности распределения
df_continent |>
group_by(continent) |>
summarize(shapiro_p = shapiro.test(`Life expectancy`)$p.value)## shapiro_p
## 1 0.001830728Распределение переменной Life expectancy значимо
отличается от нормального в исследуемых континентах (p<0.05). Можем
применить тест Манна-Уитни для сравнения распределений.
stat.test <- df_continent |>
wilcox_test(`Life expectancy` ~ continent) |>
add_xy_position(x = "continent")
stat.test## # A tibble: 1 × 11
## .y. group1 group2 n1 n2 statistic p y.position groups xmin
## <chr> <chr> <chr> <int> <int> <dbl> <dbl> <dbl> <name> <dbl>
## 1 Life exp… Africa Ameri… 52 38 107 6.34e-13 86.6 <chr> 1
## # ℹ 1 more variable: xmax <dbl>Визуализация результатов
ggboxplot(
df_continent,
x = "continent", y = "Life expectancy",
ylab = "Life expectancy", xlab = "Сontinent",
add = "jitter"
) +
labs(subtitle = get_test_label(stat.test, detailed = TRUE)) +
stat_pvalue_manual(stat.test, tip.length = 0) 
Задание 4
Сделайте новый датафрейм, в котором оставите все численные колонки
кроме Year. Сделайте корреляционный анализ этих данных.
Постройте два любых типа графиков для визуализации корреляций.
#Создадим датафрейм с количественными переменными
df_num <- df |>
select(where(is.numeric) & !`Year`)Корреляционный анализ
df_cor <- cor(df_num) |> round(2)
df_cor ## Life expectancy Unemployment
## Life expectancy 1.00 -0.12
## Unemployment -0.12 1.00
## Infant Mortality -0.83 0.10
## GDP 0.17 -0.11
## GNI 0.18 -0.11
## Clean fuels and cooking technologies 0.76 0.06
## Per Capita 0.60 -0.18
## Mortality caused by road traffic injury -0.65 0.17
## Tuberculosis Incidence -0.58 0.12
## DPT Immunization 0.50 -0.15
## HepB3 Immunization 0.40 -0.10
## Measles Immunization 0.53 -0.17
## Hospital beds 0.48 -0.15
## Basic sanitation services 0.85 0.03
## Tuberculosis treatment -0.32 -0.05
## Urban population 0.58 0.09
## Rural population -0.58 -0.09
## Non-communicable Mortality -0.63 0.13
## Sucide Rate 0.16 0.01
## Infant Mortality GDP GNI
## Life expectancy -0.83 0.17 0.18
## Unemployment 0.10 -0.11 -0.11
## Infant Mortality 1.00 -0.17 -0.16
## GDP -0.17 1.00 0.99
## GNI -0.16 0.99 1.00
## Clean fuels and cooking technologies -0.78 0.14 0.13
## Per Capita -0.32 0.17 0.18
## Mortality caused by road traffic injury 0.65 -0.12 -0.11
## Tuberculosis Incidence 0.56 -0.09 -0.09
## DPT Immunization -0.59 0.11 0.11
## HepB3 Immunization -0.53 0.09 0.08
## Measles Immunization -0.59 0.10 0.10
## Hospital beds -0.52 0.13 0.13
## Basic sanitation services -0.77 0.15 0.15
## Tuberculosis treatment 0.28 -0.02 -0.02
## Urban population -0.47 0.15 0.17
## Rural population 0.47 -0.15 -0.17
## Non-communicable Mortality 0.67 -0.19 -0.18
## Sucide Rate 0.06 0.11 0.13
## Clean fuels and cooking technologies
## Life expectancy 0.76
## Unemployment 0.06
## Infant Mortality -0.78
## GDP 0.14
## GNI 0.13
## Clean fuels and cooking technologies 1.00
## Per Capita 0.39
## Mortality caused by road traffic injury -0.60
## Tuberculosis Incidence -0.55
## DPT Immunization 0.45
## HepB3 Immunization 0.38
## Measles Immunization 0.50
## Hospital beds 0.44
## Basic sanitation services 0.84
## Tuberculosis treatment -0.31
## Urban population 0.59
## Rural population -0.59
## Non-communicable Mortality -0.66
## Sucide Rate 0.01
## Per Capita
## Life expectancy 0.60
## Unemployment -0.18
## Infant Mortality -0.32
## GDP 0.17
## GNI 0.18
## Clean fuels and cooking technologies 0.39
## Per Capita 1.00
## Mortality caused by road traffic injury -0.42
## Tuberculosis Incidence -0.31
## DPT Immunization 0.21
## HepB3 Immunization 0.09
## Measles Immunization 0.22
## Hospital beds 0.25
## Basic sanitation services 0.45
## Tuberculosis treatment -0.33
## Urban population 0.43
## Rural population -0.43
## Non-communicable Mortality -0.36
## Sucide Rate 0.32
## Mortality caused by road traffic injury
## Life expectancy -0.65
## Unemployment 0.17
## Infant Mortality 0.65
## GDP -0.12
## GNI -0.11
## Clean fuels and cooking technologies -0.60
## Per Capita -0.42
## Mortality caused by road traffic injury 1.00
## Tuberculosis Incidence 0.41
## DPT Immunization -0.34
## HepB3 Immunization -0.26
## Measles Immunization -0.31
## Hospital beds -0.49
## Basic sanitation services -0.63
## Tuberculosis treatment 0.31
## Urban population -0.37
## Rural population 0.37
## Non-communicable Mortality 0.41
## Sucide Rate -0.11
## Tuberculosis Incidence DPT Immunization
## Life expectancy -0.58 0.50
## Unemployment 0.12 -0.15
## Infant Mortality 0.56 -0.59
## GDP -0.09 0.11
## GNI -0.09 0.11
## Clean fuels and cooking technologies -0.55 0.45
## Per Capita -0.31 0.21
## Mortality caused by road traffic injury 0.41 -0.34
## Tuberculosis Incidence 1.00 -0.37
## DPT Immunization -0.37 1.00
## HepB3 Immunization -0.31 0.95
## Measles Immunization -0.37 0.88
## Hospital beds -0.20 0.32
## Basic sanitation services -0.56 0.46
## Tuberculosis treatment 0.24 -0.14
## Urban population -0.34 0.22
## Rural population 0.34 -0.22
## Non-communicable Mortality 0.48 -0.38
## Sucide Rate 0.10 0.06
## HepB3 Immunization Measles Immunization
## Life expectancy 0.40 0.53
## Unemployment -0.10 -0.17
## Infant Mortality -0.53 -0.59
## GDP 0.09 0.10
## GNI 0.08 0.10
## Clean fuels and cooking technologies 0.38 0.50
## Per Capita 0.09 0.22
## Mortality caused by road traffic injury -0.26 -0.31
## Tuberculosis Incidence -0.31 -0.37
## DPT Immunization 0.95 0.88
## HepB3 Immunization 1.00 0.86
## Measles Immunization 0.86 1.00
## Hospital beds 0.27 0.34
## Basic sanitation services 0.38 0.51
## Tuberculosis treatment -0.09 -0.14
## Urban population 0.14 0.25
## Rural population -0.14 -0.25
## Non-communicable Mortality -0.31 -0.39
## Sucide Rate -0.02 0.03
## Hospital beds Basic sanitation services
## Life expectancy 0.48 0.85
## Unemployment -0.15 0.03
## Infant Mortality -0.52 -0.77
## GDP 0.13 0.15
## GNI 0.13 0.15
## Clean fuels and cooking technologies 0.44 0.84
## Per Capita 0.25 0.45
## Mortality caused by road traffic injury -0.49 -0.63
## Tuberculosis Incidence -0.20 -0.56
## DPT Immunization 0.32 0.46
## HepB3 Immunization 0.27 0.38
## Measles Immunization 0.34 0.51
## Hospital beds 1.00 0.47
## Basic sanitation services 0.47 1.00
## Tuberculosis treatment -0.19 -0.30
## Urban population 0.27 0.55
## Rural population -0.27 -0.55
## Non-communicable Mortality -0.36 -0.52
## Sucide Rate 0.27 0.16
## Tuberculosis treatment Urban population
## Life expectancy -0.32 0.58
## Unemployment -0.05 0.09
## Infant Mortality 0.28 -0.47
## GDP -0.02 0.15
## GNI -0.02 0.17
## Clean fuels and cooking technologies -0.31 0.59
## Per Capita -0.33 0.43
## Mortality caused by road traffic injury 0.31 -0.37
## Tuberculosis Incidence 0.24 -0.34
## DPT Immunization -0.14 0.22
## HepB3 Immunization -0.09 0.14
## Measles Immunization -0.14 0.25
## Hospital beds -0.19 0.27
## Basic sanitation services -0.30 0.55
## Tuberculosis treatment 1.00 -0.28
## Urban population -0.28 1.00
## Rural population 0.28 -1.00
## Non-communicable Mortality 0.27 -0.53
## Sucide Rate -0.07 0.09
## Rural population
## Life expectancy -0.58
## Unemployment -0.09
## Infant Mortality 0.47
## GDP -0.15
## GNI -0.17
## Clean fuels and cooking technologies -0.59
## Per Capita -0.43
## Mortality caused by road traffic injury 0.37
## Tuberculosis Incidence 0.34
## DPT Immunization -0.22
## HepB3 Immunization -0.14
## Measles Immunization -0.25
## Hospital beds -0.27
## Basic sanitation services -0.55
## Tuberculosis treatment 0.28
## Urban population -1.00
## Rural population 1.00
## Non-communicable Mortality 0.53
## Sucide Rate -0.09
## Non-communicable Mortality Sucide Rate
## Life expectancy -0.63 0.16
## Unemployment 0.13 0.01
## Infant Mortality 0.67 0.06
## GDP -0.19 0.11
## GNI -0.18 0.13
## Clean fuels and cooking technologies -0.66 0.01
## Per Capita -0.36 0.32
## Mortality caused by road traffic injury 0.41 -0.11
## Tuberculosis Incidence 0.48 0.10
## DPT Immunization -0.38 0.06
## HepB3 Immunization -0.31 -0.02
## Measles Immunization -0.39 0.03
## Hospital beds -0.36 0.27
## Basic sanitation services -0.52 0.16
## Tuberculosis treatment 0.27 -0.07
## Urban population -0.53 0.09
## Rural population 0.53 -0.09
## Non-communicable Mortality 1.00 0.18
## Sucide Rate 0.18 1.00Визуализация с помощью corrplot:
corrplot(df_cor, method = 'number')
С помощью функции ggpairs из пакета
GGally:
ggpairs(df_num,
title = 'Correlations in dataset',progress = F) +
theme_minimal() +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
Задание 5
Постройте иерархическую кластеризацию на датафрейме(все численные колонки кроме Year)
df_num_scaled <- scale(df_num)
df_num_dist <- dist(df_num_scaled,
method = "euclidean"
)
# Дендрограмма кластеров
df_num_hc <- hclust(d = df_num_dist,
method = "ward.D2")
# Визуализация
fviz_dend(df_num_hc,
k = 5,
k_colors = c("#191970", "#008080", "#FFD700","#800080", "#8B0000"),
cex = 0.1,
rect = TRUE)
Задание 6
Сделайте одновременный график heatmap и иерархической кластеризации.
pheatmap(df_num_scaled,
clustering_method = "ward.D2",
cutree_rows = 5,
cutree_cols = length(colnames(df_num_scaled)),
angle_col = 90,
main = "Dendrograms for clustering rows and columns with heatmap")
При проведении кластерного анализа выделим 5 кластеров. Обращает
внимание один небольшой кластер, который характеризуется переменными GDP
и GNI с сильной корреляцией.
В другом кластере связаны столбцы,характеризующие иммунизацию
населения. В отдельной группе связаны переменные Urban population, Clean
fuels and cooking technologies, Life expectancy, Basic sanitation
services.
В другом кластере связаны переменные Unemployment, Tuberculosis
treatment, Rural population, Tuberculosis Incidence, показатели
смертности
Задание 7 - 9
Проведите PCA анализ на этих данных. Постройте biplot график для PCA.
Раскрасьте его по значениям континентов. Переведите его в
plotly. Дайте содержательную интерпретацию PCA анализу.
df_num_scaled_pca <- prcomp(df_num_scaled)
summary(df_num_scaled_pca)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.7526 1.4841 1.3952 1.17177 1.08375 0.96347 0.9288
## Proportion of Variance 0.3988 0.1159 0.1025 0.07227 0.06182 0.04886 0.0454
## Cumulative Proportion 0.3988 0.5147 0.6172 0.68945 0.75126 0.80012 0.8455
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.85740 0.69263 0.68937 0.59106 0.54986 0.47085 0.36596
## Proportion of Variance 0.03869 0.02525 0.02501 0.01839 0.01591 0.01167 0.00705
## Cumulative Proportion 0.88421 0.90946 0.93447 0.95286 0.96877 0.98044 0.98749
## PC15 PC16 PC17 PC18 PC19
## Standard deviation 0.34546 0.26941 0.20224 0.06968 1.012e-15
## Proportion of Variance 0.00628 0.00382 0.00215 0.00026 0.000e+00
## Cumulative Proportion 0.99377 0.99759 0.99974 1.00000 1.000e+00Первые 5 главных компонент объясняют 75% вариации данных. Отметка в 91% достигается только на PC9.
fviz_eig(df_num_scaled_pca, addlabels = T)
Первые две компоненты объясняют 51% дисперсии. Посмотрим, как переменные связаны с PC1 и PC2
fviz_pca_var(df_num_scaled_pca,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
Выведем самые важные переменные (для PC1 и PC2)
fviz_pca_var(df_num_scaled_pca,
select.var = list(contrib = 10), # число переменных
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
Видим группы переменных среди наиболее важных:
показатели смертности: Infant Mortality, Non-communicable Mortality
Life expectancy, Basic sanitation services, Clean fuels and cooking technologie, Urban population
показатели иммунизации населения: Measles Immunization, DPT Immunization, HepB3 Immunization
Из графика видно, что противоположное направление имеют: Urban population и Rural population, а также показатели Life expectancy и Mortality
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 1)
В первую компоненту вносят вклад большое количество переменных
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 2)
Для второй компоненты значимый вклад вносят в первую очередь показатели иммунизации
fviz_contrib(df_num_scaled_pca, choice = "var", axes = 3)
Третья компонента характеризуется хорошо показателями GDP и GNI
#biplot график для PCA
df_num_scaled_biplot <- ggbiplot(df_num_scaled_pca,
repel = TRUE,
groups = as.factor(df$continent))
df_num_scaled_biplot
plotly::ggplotly(df_num_scaled_biplot)Достаточно хорошо на графике различимы страны Европы и Америки, для которых характерны большая продолжительность жизни, высокий процент городского населения, уровень иммунизации и в противоположной стороне страны Африки, характеризующиеся преимущественно сельским населением, повышенной смертностью от разных причин
Задание 10
Сравните результаты отображения точек между алгоритмами PCA и UMAP.
#из лекции
umap_prep <- recipe(~., data = df_num) |>
step_normalize(all_predictors()) |>
step_umap(all_predictors()) |>
prep() |>
juice() umap_prep |>
ggplot(aes(UMAP1, UMAP2)) +
geom_point(aes(color = as.character(df$continent))) +
labs(color = NULL) 
При сравнении алгоритмов получаем схожие результаты: в одну группу попадают преимущественно страны Африки, в другую - Страны Европы и Америки. В UMAP точки ближе друг к другу, лучше визуализируются 2 кластера.
Задание 11
Удалите 5 случайных колонок. Проведите PCA анализ. Повторите результат 3 раза. Наблюдаете ли вы изменения в куммулятивном проценте объяснённой вариации? В итоговом представлении данных на биплотах? С чем связаны изменения между тремя PCA?
set.seed(111)
df_num_scaled <- as.data.frame(df_num_scaled)
df_num_scaled1 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))df_num_scaled_pca1 <- prcomp(df_num_scaled1)
summary(df_num_scaled_pca1)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.3409 1.3241 1.1930 1.05866 0.98243 0.89639 0.85050
## Proportion of Variance 0.3914 0.1252 0.1017 0.08005 0.06894 0.05739 0.05167
## Cumulative Proportion 0.3914 0.5167 0.6183 0.69836 0.76730 0.82470 0.87637
## PC8 PC9 PC10 PC11 PC12 PC13
## Standard deviation 0.69834 0.68612 0.56897 0.48609 0.41389 0.20280
## Proportion of Variance 0.03483 0.03363 0.02312 0.01688 0.01224 0.00294
## Cumulative Proportion 0.91120 0.94483 0.96795 0.98483 0.99706 1.00000
## PC14
## Standard deviation 2.454e-16
## Proportion of Variance 0.000e+00
## Cumulative Proportion 1.000e+00fviz_eig(df_num_scaled_pca1, addlabels = T)
fviz_pca_var(df_num_scaled_pca1,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
set.seed(222)
df_num_scaled2 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))df_num_scaled_pca2 <- prcomp(df_num_scaled2)
summary(df_num_scaled_pca2)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.3936 1.4007 1.2249 1.0973 0.98939 0.89446 0.71756
## Proportion of Variance 0.4092 0.1401 0.1072 0.0860 0.06992 0.05715 0.03678
## Cumulative Proportion 0.4092 0.5494 0.6566 0.7426 0.81248 0.86963 0.90641
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.62212 0.59925 0.47278 0.38590 0.33450 0.27368 0.07027
## Proportion of Variance 0.02765 0.02565 0.01597 0.01064 0.00799 0.00535 0.00035
## Cumulative Proportion 0.93405 0.95970 0.97567 0.98630 0.99430 0.99965 1.00000fviz_eig(df_num_scaled_pca2, addlabels = T)
fviz_pca_var(df_num_scaled_pca2,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
set.seed(333)
df_num_scaled3 <- df_num_scaled |>
select(-sample(names(df_num_scaled), 5))df_num_scaled_pca3 <- prcomp(df_num_scaled3)
summary(df_num_scaled_pca3)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.4009 1.3898 1.2955 1.11213 0.96916 0.90270 0.72369
## Proportion of Variance 0.4118 0.1380 0.1199 0.08835 0.06709 0.05821 0.03741
## Cumulative Proportion 0.4118 0.5497 0.6696 0.75793 0.82502 0.88322 0.92063
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.65628 0.53057 0.4821 0.34509 0.20610 0.07007 2.857e-16
## Proportion of Variance 0.03076 0.02011 0.0166 0.00851 0.00303 0.00035 0.000e+00
## Cumulative Proportion 0.95140 0.97151 0.9881 0.99662 0.99965 1.00000 1.000e+00fviz_eig(df_num_scaled_pca3, addlabels = T)
fviz_pca_var(df_num_scaled_pca3,
col.var = "contrib",
repel = TRUE # убрать наслаивание меток переменных
)
ggplotly(ggbiplot(df_num_scaled_pca1,
repel = TRUE,
groups = as.factor(df$continent)) )ggplotly(ggbiplot(df_num_scaled_pca2,
repel = TRUE,
groups = as.factor(df$continent)) )ggplotly(ggbiplot(df_num_scaled_pca3,
repel = TRUE,
groups = as.factor(df$continent)) )Во всех случаях кумулятивный процент объясненной вариации первых двух компонент более 50%. В зависимости от того какие колонки были удалены, мы получаем разный вклад переменных в компоненты. Полученные биплоты достаточно сильно отличаются друг от друга.